home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / modules.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  38KB  |  1,678 lines
  1. /* ******************************************************************** */
  2. /*  modules.c        copyright (c) codemist and university of bath 1989 */
  3. /*                                                                      */
  4. /* creation of modules                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: modules.c,v 1.22 1992/03/14 16:39:20 pab Exp $
  9.  *
  10.  * $Log: modules.c,v $
  11.  * Revision 1.22  1992/03/14  16:39:20  pab
  12.  * arg checking (again)
  13.  *
  14.  * Revision 1.21  1992/03/14  14:33:48  pab
  15.  * bytecode optional
  16.  *
  17.  * Revision 1.20  1992/03/07  21:45:16  pab
  18.  * apply changes
  19.  *
  20.  * Revision 1.19  1992/02/27  15:48:17  pab
  21.  * bytecode additions
  22.  *
  23.  * Revision 1.18  1992/02/10  12:06:20  pab
  24.  * new apply functions
  25.  *
  26.  * Revision 1.17  1992/02/02  16:33:47  pab
  27.  * improved backtrace output
  28.  *
  29.  * revision 1.12  1991/04/02  21:25:30  kjp
  30.  * compiler tidying.
  31.  *
  32.  * revision 1.11  1991/03/27  17:37:32  kjp
  33.  * fixed some definition ordering problems.
  34.  *
  35.  * revision 1.10  1991/03/14  14:14:14  fdla
  36.  * *** empty log message ***
  37.  *
  38.  * revision 1.9  1991/03/14  11:43:54  fdla
  39.  * c and elvira function switches expanded (20 args)
  40.  *
  41.  * revision 1.8  1991/03/13  16:57:34  kjp
  42.  * no change.
  43.  *
  44.  * revision 1.7  1991/02/19  18:53:04  kjp
  45.  * (expose spec*) in module body for reexportation.
  46.  *
  47.  * revision 1.6  1991/02/19  17:07:17  kjp
  48.  * updated for new module syntax with full streaming.
  49.  *
  50.  * revision 1.5  1991/02/13  18:24:17  kjp
  51.  * pass.
  52.  *
  53.  */
  54.  
  55. /*
  56.  * change log:
  57.  *   version 1, may 1989
  58.  *    major rewrite after talking to jap
  59.  *    added include function
  60.  *
  61.  *      threw it all away and did it again 'right' ! kjp (15/3/90)    
  62.  *    Did the same... pab (11/91)
  63.  */
  64. #define call_generic foo
  65.  
  66. #include "defs.h"
  67. #include "structs.h"
  68. #include "funcalls.h"
  69.  
  70. #include "error.h"
  71. #include "global.h"
  72.  
  73.  
  74. #include "allocate.h"
  75. #include "lists.h"
  76. #include "table.h"
  77. #include "modules.h"
  78. #include "toplevel.h"
  79. #include "symboot.h"
  80. #include "specials.h"
  81. #include "root.h"
  82. #include "class.h"
  83. #include "ngenerics.h"
  84. #include "calls.h"
  85. #include "bvf.h"
  86.  
  87. #undef call_generic
  88. /* elsewheres... */
  89. EUDECL(call_generic);
  90. /* in modules.h */
  91. EUDECL(Fn_module_value);
  92. static EUDECL(module_set_new_aux);
  93. EUDECL(register_module_import);
  94.  
  95. static LispObject sym_include_forms;
  96.  
  97. SYSTEM_GLOBAL(LispObject,current_interactive_module);
  98.  
  99. /* global module table - gc hook */ /* hack !!! */
  100.  
  101. LispObject global_module_table;
  102.  
  103. /* hooking / unhooking */
  104.  
  105. LispObject put_module(LispObject *stacktop, LispObject name,LispObject module)
  106. {
  107.   if (global_module_table == NULL) {
  108.     fprintf(stderr,"initerror: NULL module table");
  109.     exit(1);
  110.   }
  111.  
  112.   STACK_TMP(name);
  113.   EUCALL_3(tref_updator, global_module_table,name,module);
  114.   UNSTACK_TMP(name);
  115.   return(name);
  116. }
  117.  
  118. LispObject get_module(LispObject *stacktop, LispObject name)
  119. {
  120.   ARG_1(stacktop) = name;
  121.   ARG_0(stacktop) = global_module_table;
  122.   return(Fn_tref(stacktop));
  123. }
  124.  
  125. int module_loaded_p(LispObject* stacktop, LispObject name)
  126. {
  127.   return((get_module(stacktop, name) != nil));
  128. }
  129.  
  130. /* utilities !! */
  131.  
  132.  
  133. LispObject module_exports(LispObject mod)
  134. {
  135.   if (is_c_module(mod)) return(mod->C_MODULE.exported_names);
  136.   if (is_i_module(mod)) return(mod->I_MODULE.exported_names);
  137.  
  138.   CallError(NULL, "module exports: unknown module type",mod,NONCONTINUABLE);
  139.  
  140.   return(nil);
  141. }
  142.  
  143. void process_expose_form(LispObject *stacktop,LispObject mod,LispObject forms)
  144. {
  145.   static LispObject export_filter(LispObject *,LispObject,LispObject);
  146.   LispObject union_filter(LispObject *,LispObject,LispObject);
  147.   LispObject xx;
  148.  
  149.   STACK_TMP(mod);
  150.   xx=union_filter(stacktop,forms,mod);
  151.   UNSTACK_TMP(mod);
  152.   (void) export_filter(stacktop,xx,mod);
  153. }    
  154.       
  155. EUFUN_2( process_exports, mod, names)
  156. {
  157.  
  158.   if (is_c_module(mod))
  159.     CallError(stacktop,
  160.           "process exports: can't modify compiled module exports",
  161.           mod,NONCONTINUABLE);
  162.  
  163.   if (is_i_module(mod)) {
  164.     LispObject walker = names;
  165.  
  166.     if (names == nil) return nil;
  167.  
  168.     mod->I_MODULE.bounce_flag = TRUE;
  169.  
  170.     while (is_cons(walker)) {
  171.  
  172.       if (!is_symbol(CAR(walker))) {
  173.     STACK_TMP(walker);
  174.     EUCALL_2(process_top_level_form,ARG_1(stackbase)/*mod*/,CAR(walker)); 
  175.     UNSTACK_TMP(walker);
  176.       }
  177.       walker = CDR(walker);
  178.     }
  179.  
  180.     mod = ARG_0(stackbase);
  181.     mod->I_MODULE.bounce_flag = FALSE;
  182.  
  183.     /* all valid exports */
  184.  
  185.     walker = ARG_1(stackbase);
  186.  
  187.     while(is_cons(walker)) {
  188.       if (is_symbol(CAR(walker))) {
  189.     LispObject xx;
  190.     STACK_TMP(walker);
  191.     EUCALLSET_2(xx, Fn_memq,CAR(walker),mod->I_MODULE.exported_names);
  192.     UNSTACK_TMP(walker);
  193.     if (xx == nil) {
  194.       LispObject xx;
  195.       mod = ARG_0(stackbase);
  196.       STACK_TMP(walker);
  197.       EUCALLSET_2(xx, Fn_cons, CAR(walker),mod->I_MODULE.exported_names);
  198.       mod = ARG_0(stackbase);
  199.       mod->I_MODULE.exported_names = xx;
  200.       UNSTACK_TMP(walker);
  201.     }
  202.       }
  203.  
  204.       walker = CDR(walker);
  205.     }
  206.  
  207.     return nil;
  208.   }
  209.  
  210.   CallError(stacktop, "process exports: non-module arg",mod,NONCONTINUABLE);
  211. }
  212. EUFUN_CLOSE
  213.  
  214. EUFUN_2( process_included_forms, mod, forms)
  215. {
  216.   extern LispObject Fn_close(LispObject*);
  217.  
  218.   LispObject path,stream,read;
  219.   FILE *cstream;
  220.  
  221.   if (!is_cons(forms))
  222.     CallError(stacktop, "inlude-forms: missing path",forms,NONCONTINUABLE);
  223.  
  224.   if (!is_string((path = CAR(forms))))
  225.     CallError(stacktop, "include-forms: bad path",path,NONCONTINUABLE);
  226.  
  227.   cstream = fopen(stringof(path),"r");
  228.   if (cstream == NULL)
  229.     CallError(stacktop, "include-forms: can't open file",path,NONCONTINUABLE);
  230.  
  231.   stream = (LispObject) allocate_stream(stacktop, cstream,'r');
  232.  
  233.   fprintf(StdOut->STREAM.handle,"including \'%s\'\n",stringof(path));
  234.  
  235.   while (1) {
  236.     STACK_TMP(stream);
  237.     EUCALLSET_1(read, Fn_read, stream);
  238.     UNSTACK_TMP(stream);
  239.     if (read == q_eof) break;
  240.     STACK_TMP(stream);
  241.     EUCALLSET_2(read,process_top_level_form,ARG_0(stackbase),read);
  242.     UNSTACK_TMP(stream);
  243.   }
  244.  
  245.   EUCALL_1(Fn_close, stream);
  246.  
  247.   fprintf(StdOut->STREAM.handle,"included \'%s\'\n",stringof(path));
  248.  
  249. }
  250. EUFUN_CLOSE
  251.  
  252. static LispObject sym_only;
  253. static LispObject sym_except;
  254.  
  255. static LispObject module_addresses(LispObject *stacktop, LispObject mod)
  256. {
  257.   LispObject exports,addresses;
  258.  
  259.   addresses = nil;
  260.   exports = mod->I_MODULE.exported_names;
  261.  
  262.   
  263.   while (is_cons(exports)) {
  264.     LispObject name, xx;
  265.     STACK_TMP(CDR(exports));
  266.     STACK_TMP(mod);
  267.     STACK_TMP(addresses);
  268.  
  269.     name = CAR(exports);
  270.     
  271.     EUCALLSET_2(xx, Fn_cons, name, mod); /* canonical address */
  272.     EUCALLSET_2(name,Fn_cons, CAR(xx)/*name*/, xx);
  273.     UNSTACK_TMP(addresses);
  274.     EUCALLSET_2(addresses, Fn_cons,name, addresses);
  275.     UNSTACK_TMP(mod);
  276.     UNSTACK_TMP(exports);
  277.   }
  278.  
  279.  
  280.   return(addresses);
  281. }
  282.  
  283. /* filters */
  284.  
  285. static LispObject only_filter(LispObject *stacktop,
  286.                   LispObject names,LispObject addresses)
  287. {
  288.   LispObject remains;
  289.  
  290.   remains = nil;
  291.  
  292.   while (is_cons(addresses)) {
  293.  
  294.     STACK_TMP(addresses);
  295.     STACK_TMP(remains);
  296.     if (EUCALL_2(Fn_memq,CAR(CAR(addresses)),names) != nil) {
  297.       UNSTACK_TMP(remains);
  298.       STACK_TMP(names);
  299.       EUCALLSET_2(remains, Fn_cons, CAR(addresses),remains);
  300.       UNSTACK_TMP(names);
  301.     }
  302.     else UNSTACK_TMP(remains);
  303.  
  304.     UNSTACK_TMP(addresses);
  305.     addresses = CDR(addresses);
  306.  
  307.   }
  308.  
  309.   return(remains);
  310. }
  311.  
  312. static LispObject except_filter(LispObject *stacktop,
  313.                 LispObject names,LispObject addresses)
  314. {
  315.   LispObject remains;
  316.  
  317.   remains = nil;
  318.  
  319.   while (is_cons(addresses)) {
  320.  
  321.     STACK_TMP(addresses);
  322.  
  323.     if (EUCALL_2(Fn_memq,CAR(CAR(addresses)),names) == nil) 
  324.       {
  325.     STACK_TMP(names);
  326.     EUCALLSET_2(remains, Fn_cons, CAR(addresses),remains);
  327.     UNSTACK_TMP(names);
  328.       }
  329.  
  330.     UNSTACK_TMP(addresses);
  331.  
  332.     addresses = CDR(addresses);
  333.  
  334.   }
  335.  
  336.   return(remains);
  337. }
  338.  
  339. static LispObject name_list_pair(LispObject *stacktop,
  340.                  LispObject k,LispObject l)
  341. {
  342.   while (is_cons(l)) {
  343.  
  344.     if (!is_cons(CAR(l)))
  345.       CallError(stacktop,
  346.         "module importation: bad rename names",l,NONCONTINUABLE);
  347.  
  348.     if (k == CAR(CAR(l))) 
  349.       return(CAR(l));
  350.     else
  351.       l = CDR(l);
  352.   }
  353.  
  354.   return(nil);
  355. }
  356.  
  357. static LispObject rename_filter(LispObject *stacktop,
  358.                 LispObject pairs,LispObject addresses)
  359. {
  360.   LispObject walker;
  361.  
  362.   walker = addresses;
  363.  
  364.   while (is_cons(walker)) {
  365.     LispObject pair;
  366.     STACK_TMP(walker);
  367.     pair = name_list_pair(stacktop,CAR(CAR(walker)),pairs);
  368.     UNSTACK_TMP(walker);
  369.     if (pair != nil) { /* to be renamed... */
  370.  
  371.       CAR(CAR(walker)) = CAR(CDR(pair));
  372.  
  373.     }
  374.  
  375.     walker = CDR(walker);
  376.   }
  377.   
  378.   return(addresses);
  379. }
  380.  
  381. LispObject
  382.   union_filter(LispObject *stacktop, LispObject list,LispObject context)
  383. {
  384.   static LispObject filter_import_thang(LispObject*,LispObject,LispObject);
  385.   LispObject all;
  386.  
  387.   all = nil;
  388.  
  389.   while (is_cons(list)) {
  390.     LispObject xx;
  391.  
  392.     STACK_TMP(CDR(list));
  393.     STACK_TMP(context);
  394.     STACK_TMP(all);
  395.     xx = filter_import_thang(stacktop,CAR(list),context);
  396.     UNSTACK_TMP(all);
  397.     EUCALLSET_2(all, Fn_nconc, xx,all);
  398.     UNSTACK_TMP(context);
  399.  
  400.     UNSTACK_TMP(list);
  401.  
  402.   }
  403.  
  404.   return(all);
  405. }
  406.  
  407. static LispObject export_filter(LispObject *stacktop,
  408.                 LispObject ads,LispObject mod)
  409. {
  410.   LispObject walker;
  411.   
  412.   STACK_TMP(ads);
  413.   walker = ads;
  414.  
  415.   while (is_cons(walker)) {
  416.     LispObject name;
  417.  
  418.     name = CAR(CAR(walker)); 
  419.  
  420.     STACK_TMP(CDR(walker));
  421.  
  422.     STACK_TMP(mod);
  423.     STACK_TMP(name);
  424.     if (EUCALL_2(Fn_memq,name,mod->I_MODULE.exported_names) == nil)
  425.       {
  426.     LispObject xx;
  427.     UNSTACK_TMP(name);
  428.     EUCALLSET_2(xx, Fn_cons,name,mod->I_MODULE.exported_names);
  429.     UNSTACK_TMP(mod);
  430.     mod->I_MODULE.exported_names = xx;
  431.       }
  432.     else 
  433.       { UNSTACK_TMP(name);    
  434.     UNSTACK_TMP(mod);
  435.       }
  436.     UNSTACK_TMP(walker);
  437.  
  438.   }
  439.  
  440.   UNSTACK_TMP(ads);
  441.   return(ads);
  442. }
  443.  
  444. static void register_filtered_addresses(LispObject *stacktop,
  445.                     LispObject ads,LispObject mod)
  446. {
  447.   while (is_cons(ads)) {
  448.     LispObject first;
  449.     
  450.     first = CAR(ads); ads = CDR(ads);
  451.     STACK_TMP(mod);
  452.     STACK_TMP(ads);
  453.     EUCALL_4(register_module_import,mod,
  454.          CAR(first),CDR(CDR(first)),
  455.          CAR(CDR(first)));
  456.     UNSTACK_TMP(ads);
  457.     UNSTACK_TMP(mod);
  458.   }
  459. }
  460.     
  461. static LispObject filter_import_thang(
  462.               LispObject* stacktop, LispObject spec,LispObject context)
  463. {
  464.   LispObject op,xx;
  465.  
  466.   if (is_symbol(spec)) {
  467.     STACK_TMP(spec);
  468.     EUCALL_1(load_module,spec);
  469.     UNSTACK_TMP(spec);
  470.     xx= get_module(stacktop,spec);
  471.     return(module_addresses(stacktop,xx));
  472.   }
  473.  
  474.   if (!is_cons(spec)) 
  475.     CallError(stacktop, "module importation: invalid import spec",spec,NONCONTINUABLE);
  476.  
  477.   op = CAR(spec); spec = CDR(spec);
  478.  
  479.   if (op == sym_only) {
  480.     
  481.     if (!is_cons(spec))
  482.       CallError(stacktop, "module importation: bad only form",spec,NONCONTINUABLE);
  483.     
  484.     STACK_TMP(CAR(spec));
  485.     xx=union_filter(stacktop, CDR(spec),context);
  486.     UNSTACK_TMP(spec);
  487.     return(only_filter(stacktop,spec,xx));
  488.  
  489.   }
  490.  
  491.   if (op == sym_except) {
  492.  
  493.     if (!is_cons(spec))
  494.       CallError(stacktop, "module importation: bad except form",spec,NONCONTINUABLE);
  495.     STACK_TMP(CAR(spec));
  496.     xx=union_filter(stacktop, CDR(spec),context);
  497.     UNSTACK_TMP(spec);
  498.     return(except_filter(stacktop,spec,xx));
  499.  
  500.   }
  501.  
  502.   if (op == sym_rename) {
  503.  
  504.     if (!is_cons(spec))
  505.       CallError(stacktop, "module importation: bad rename form",spec,NONCONTINUABLE);
  506.     STACK_TMP(CAR(spec));
  507.     xx= union_filter(stacktop, CDR(spec),context);
  508.     UNSTACK_TMP(spec);
  509.     return(rename_filter(stacktop,spec,xx));
  510.  
  511.   }
  512.  
  513.   if (op == sym_export) {
  514.     STACK_TMP(spec); STACK_TMP(context);
  515.     xx=union_filter(stacktop, spec,context);
  516.     UNSTACK_TMP(context); UNSTACK_TMP(spec);
  517.     return(export_filter(stacktop,xx,context));
  518.  
  519.   }
  520.  
  521.   CallError(stacktop, "module importation: invalid import operation",op,NONCONTINUABLE);
  522.  
  523.   return(nil);
  524. }
  525.  
  526. void process_import_form(LispObject *stackbase,LispObject mod,LispObject spec)
  527. {
  528.   LispObject *stacktop=stackbase+1;
  529.   
  530.   ARG_0(stackbase)=mod;
  531.  
  532.   if (!is_cons(spec))
  533.     CallError(stacktop,
  534.           "import: invalid NULL import spec",spec,NONCONTINUABLE);
  535.  
  536.   while (is_cons(spec)) {
  537.     LispObject name = CAR(spec);
  538.     STACK_TMP(CDR(spec));
  539.  
  540.     if (is_symbol(name)) {
  541.       LispObject inmod,exports;
  542.       
  543.       STACK_TMP(name);
  544.       EUCALL_1(load_module,name);
  545.       UNSTACK_TMP(name);
  546.  
  547.       inmod = get_module(stacktop,name);
  548.       mod=ARG_0(stackbase);
  549.       exports = module_exports(inmod);
  550.  
  551.       while (exports != nil) {
  552.     STACK_TMP(mod);
  553.     STACK_TMP(inmod);
  554.     STACK_TMP(CDR(exports));
  555.     EUCALL_4(register_module_import,ARG_0(stackbase)/*mod*/,
  556.          CAR(exports),inmod,CAR(exports));
  557.     UNSTACK_TMP(exports);
  558.     UNSTACK_TMP(inmod);
  559.     UNSTACK_TMP(mod);
  560.       }
  561.  
  562.     }
  563.     else {
  564.       
  565.       CallError(stacktop,
  566.         "import: non-symbolic module name",spec,NONCONTINUABLE);
  567.  
  568.     }
  569.  
  570.     UNSTACK_TMP(spec);
  571.  
  572.   }
  573.  
  574. }
  575.  
  576. void process_import_spec(LispObject *stacktop, LispObject mod,LispObject spec)
  577. {
  578.   LispObject xx;
  579.   STACK_TMP(mod);
  580.   xx=union_filter(stacktop, spec,mod);
  581.   UNSTACK_TMP(mod);
  582.   register_filtered_addresses(stacktop,xx,mod);
  583. }
  584.  
  585.  
  586. EUFUN_2(process_top_level_form, mod, form)
  587. {
  588.   LispObject op;
  589.  
  590.   /* ok, so here's the game plan -
  591.    
  592.    * for each form, check out the car.
  593.    * if it's not a symbol - crash, probably, for the moment...
  594.    * a symbol means check out any imported macros...
  595.    *   no macros means check out special form key words...
  596.    *     none of them means error.
  597.    * expand macros once and try again.
  598.    * for matching keywords, do the bizness
  599.  
  600.    */
  601.  
  602.  top:
  603.   /* interactive hack */
  604.  
  605.   if (!is_cons(form)) RETURN_EUCALL(EUCALL_3(module_eval,mod,NULL,form));
  606.  
  607.   op = CAR(form); 
  608.  
  609.   if (is_symbol(op)) {
  610.  
  611.     /* really just check for defining forms and 'progn' */
  612.  
  613.     if (op == sym_progn) {
  614.       LispObject walker,ans = nil;
  615.       walker = form;
  616.  
  617.       walker = CDR(walker);
  618.       while (is_cons(walker)) {
  619.     STACK_TMP(CDR(walker));
  620.     mod = ARG_0(stackbase);
  621.     EUCALLSET_2(ans, process_top_level_form,mod,CAR(walker));
  622.     UNSTACK_TMP(walker);
  623.       }
  624.  
  625.       return(ans);
  626.     }
  627.  
  628.     /*
  629.     if (op == sym_define) {
  630.       return(TL_define(stacktop,mod,CDR(form)));
  631.     }
  632.     */
  633.     if (op == sym_defun)       {
  634.       return(TL_defun(stacktop,mod,CDR(form)));
  635.     }
  636.     if (op == sym_deflocal) {
  637.       return(TL_deflex(stacktop,mod,CDR(form)));
  638.     }
  639.     if (op == sym_defmacro) {
  640.       return(TL_defmacro(stacktop,mod,CDR(form)));
  641.     }
  642.  
  643.     if (op == sym_defvar) return(TL_defvar(stacktop,mod,CDR(form)));
  644.       
  645.     if (op == sym_defconstant) return(TL_defconstant(stacktop,mod,CDR(form))); 
  646.  
  647.     if (op == sym_import) {
  648.       process_import_form(stacktop,mod,CDR(form));
  649.       return(nil);
  650.     }
  651.  
  652.     if (op == sym_expose) {
  653.       process_expose_form(stacktop,mod,CDR(form)); 
  654.       return(nil);
  655.     }
  656.  
  657.     if (op == sym_export) {
  658.       EUCALL_2(process_exports,mod,CDR(form));
  659.       return(nil);
  660.     }
  661.  
  662.     if (op == sym_include_forms) {
  663.       EUCALL_2(process_included_forms,mod,CDR(form));
  664.       return(nil);
  665.     }
  666.  
  667.     /* hell, that'll do for now */
  668.  
  669.     /* try a macroexpand... */
  670.  
  671.     EUCALLSET_2(form,macroexpand_1,mod,form);
  672.     
  673.     if (CAR(CDR(form)) != nil) {
  674.       while (CAR(CDR(form))!=nil)
  675.     { form = CAR(form);
  676.       mod=ARG_0(stackbase);
  677.       EUCALLSET_2(form, macroexpand_1,mod,form);
  678.     }
  679.       
  680.       form = CAR(form);
  681.       
  682.       mod=ARG_0(stackbase);
  683.       goto top;
  684.     }
  685.  
  686.     form = CAR(form);
  687.  
  688.     /* not a macro... */
  689.  
  690.     /* ok, so for user-friendliness (ho-ho) just to a module eval */
  691.  
  692.     mod=ARG_0(stackbase);
  693.     RETURN_EUCALL(EUCALL_3(module_eval,mod,NULL,form));
  694.   }
  695.  
  696.   /* wasne a symbol - rather than crash, try eval first */
  697.  
  698.   {
  699.     LispObject ans;
  700.  
  701.     EUCALLSET_3(ans,module_eval,mod,NULL,form);
  702.     return(ans);
  703.   }
  704. }
  705. EUFUN_CLOSE
  706.  
  707. /* biggie!! */
  708.  
  709. LispObject backtrace_handle;
  710. LispObject list_backtrace;
  711.  
  712. #define PUSH_TRACE(fun,args) \
  713.   { \
  714.     STACK_TMP(args); STACK_TMP(fun); STACK_TMP(backtrace_handle); \
  715.   }
  716.  
  717. #define SET_TRACE(sp,op,env)    \
  718. {                \
  719.    *(sp)=env;            \
  720.    *((sp)+1)=op;            \
  721.    *((sp)+2)=backtrace_handle;    \
  722. }
  723.  
  724. void quickie_module_eval_backtrace(LispObject *stacktop)
  725. {
  726.   LispObject *walker;
  727.  
  728.   fprintf(StdOut->STREAM.handle,"\n");
  729.  
  730.   for (walker = GC_STACK_BASE(); walker != GC_STACK_POINTER(); ++walker) {
  731.     
  732.     if ((*(walker)) == backtrace_handle) {
  733.       
  734.       fprintf(StdOut->STREAM.handle,"entered: ");
  735.       EUCALL_2(Fn_print, ((*(walker-1)))->FUNCTION.name,StdOut);
  736.  
  737.     }
  738.  
  739.   }
  740.  
  741.   fprintf(StdOut->STREAM.handle,"\n");
  742.  
  743. }
  744.  
  745. void module_eval_backtrace(LispObject *stacktop)
  746. {
  747.   LispObject *walker;
  748.   Env env;
  749.  
  750.   for (walker = GC_STACK_BASE(); walker != stacktop; ++walker) {
  751.     
  752.     if (*walker == backtrace_handle) {
  753.       
  754.       fprintf(StdOut->STREAM.handle,"\n");
  755.       fprintf(StdOut->STREAM.handle,"entered: ");
  756.       EUCALL_2(Fn_print,((*(walker-1)))->FUNCTION.name,StdOut);
  757.       fprintf(StdOut->STREAM.handle,"\n");
  758.  
  759.       if ((*(walker-2)) != NULL && typeof((*(walker-2))) == TYPE_ENV) {
  760.  
  761.     for (env = (Env) (*(walker-2)); env != NULL; env = env->next) {
  762.  
  763.       fprintf(StdOut->STREAM.handle,"  ");
  764.       STACK_TMPV(env);
  765.       EUCALL_2(Fn_prin,env->variable,StdOut);
  766.       UNSTACK_TMPV(env);
  767.       STACK_TMPV(env);
  768.       fprintf(StdOut->STREAM.handle,": ");
  769.       EUCALL_2(Gf_generic_prin,env->value,StdOut);
  770.       fprintf(StdOut->STREAM.handle,"\n");
  771.       UNSTACK_TMPV(env);
  772.     }
  773.  
  774.       }
  775.  
  776.     }
  777.  
  778.   }
  779.  
  780.   fprintf(StdOut->STREAM.handle,"\n");
  781.  
  782. }
  783.  
  784. /*
  785.   *
  786.   * The interpreter lies below 
  787.   */
  788.  
  789. #define check_if(stmt) /* :-> */
  790.  
  791. LispObject module_eval(LispObject *stackbase)
  792. {
  793.   LispObject op;
  794.   LispObject mod,env,form;
  795.   LispObject *stacktop;
  796.  
  797.   mod = ARG_0(stackbase);
  798.   env = ARG_1(stackbase);
  799.   form = ARG_2(stackbase);
  800.   (void) system_stacks_ok_p(stackbase,form); 
  801.   
  802.  
  803.   stackbase+=3;    /* Room for trace */
  804.   ARG_0(stackbase)=mod;
  805.   ARG_1(stackbase)=env;
  806.   ARG_2(stackbase)=form;
  807.  toplabel:  
  808.   mod = ARG_0(stackbase);
  809.   env = ARG_1(stackbase);
  810.   form = ARG_2(stackbase);
  811.  
  812.   stacktop=stackbase+3;
  813.  
  814.   if (!is_cons(form))
  815.     { /* should check for loose special forms */
  816.       if (is_symbol(form))
  817.     {
  818.       LispObject tmp=symbol_ref(stacktop,mod,env,form);
  819.       if (!is_special(tmp)) return(tmp);
  820.       else    
  821.         CallError(stacktop,"Invalid use of reservered word",form,NONCONTINUABLE);
  822.     }
  823.       else    
  824.     return form;
  825.     }
  826.  
  827.   op = CAR(form);
  828.  
  829.   ARG_3(stackbase)=op;
  830.   stacktop++;
  831.  
  832.   if (is_symbol(op))
  833.     { 
  834. #ifndef NODEBUG
  835.       { extern int gc_paranoia;
  836.     if (gc_paranoia)
  837.       fprintf(stderr,"%s\n",op->SYMBOL.pname);
  838.       }
  839. #endif
  840.       op = symbol_ref(stacktop,mod,(LispObject)env,op);
  841.       ARG_3(stackbase)=op;
  842.     }
  843.   else
  844.     if (is_cons(op))
  845.       {    
  846.     op=EUCALL_3(module_eval,mod,env,op);
  847.     ARG_3(stackbase)=op;
  848.     mod=ARG_0(stackbase);
  849.     env=ARG_1(stackbase);
  850.     form=ARG_2(stackbase);
  851.       }
  852.  
  853.   if (is_macro(op))
  854.     { LispObject newform;
  855.       newform = EUCALL_2(module_mv_apply_1,op,CDR(form));
  856.  
  857.  
  858.       if (!is_cons(newform))
  859.     EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,newform)
  860.       else
  861.     {
  862.       CAR(form) = CAR(newform);
  863.       CDR(form) = CDR(newform);
  864.       EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,form);
  865.     }
  866.     }
  867.  
  868.  
  869.  
  870.   if (is_c_function(op) || is_c_macro(op) 
  871. #ifdef BCI
  872.       || is_b_function(op) || is_b_macro(op)
  873. #endif
  874.       )
  875.     {
  876.       LispObject lastarg;
  877.  
  878.       LispObject walker, extras = nil;
  879.       int i, args, extra;
  880.       BEGIN_NARY_EUCALL();
  881.  
  882.       walker = CDR(form);
  883.       args = ((is_c_function(op)||is_c_macro(op))
  884.           ? op->C_FUNCTION.argtype
  885.           : intval(bytefunction_nargs(op)));
  886.  
  887.       extra = (args < 0);
  888.       args = extra ? -args : args;
  889.       
  890.       if (is_c_function(op) || is_c_macro(op))
  891.     if (op->C_FUNCTION.env != NULL)
  892.       { STACK_TMP(nil); /* space for arg */
  893.         NARY_PUSH_ARG((LispObject)op->C_FUNCTION.env);
  894.       }
  895.  
  896.       if (args==0)
  897.     {
  898.       if (walker!=nil)
  899.         CallError(stacktop,"Too many args to C-fn",op,NONCONTINUABLE);
  900.       else
  901.         return(op->C_FUNCTION.func(stackbase));
  902.     }
  903.  
  904.       for (i=0; i < args-1 ; i++)
  905.     {
  906.       STACK_TMP(nil); /* place where arg will go */
  907.       STACK_TMP(CDR(walker));
  908.       /* XXX assume 1) CDR(nil)=nil, module_eval(nil)=nil */
  909.       NARY_PUSH_ARG(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,
  910.                  ARG_1(stackbase)/* env */,CAR(walker)));
  911.       UNSTACK_TMP(walker);
  912.     }
  913.  
  914.       if (extra)
  915.     { 
  916.       LispObject ptr;
  917.  
  918.       if (walker!=nil)
  919.         {
  920.           LispObject xx;
  921.  
  922.           STACK_TMP(CDR(walker));
  923.           EUCALLSET_3(xx,module_eval,ARG_0(stackbase) /*mod*/,
  924.                               ARG_1(stackbase)/*env*/, CAR(walker));
  925.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  926.           UNSTACK_TMP(walker);
  927.           STACK_TMP(lastarg);
  928.           ptr = lastarg;
  929.           while(walker!=nil)
  930.         {    
  931.           STACK_TMP(CDR(walker));
  932.           STACK_TMP(ptr);
  933.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase)    /*mod*/, 
  934.                   ARG_1(stackbase)/*env*/, CAR(walker));
  935.           xx = EUCALL_2(Fn_cons, xx, nil);
  936.           UNSTACK_TMP(ptr);
  937.           CDR(ptr)=xx;
  938.           ptr = CDR(ptr);
  939.           UNSTACK_TMP(walker);
  940.         }
  941.           UNSTACK_TMP(lastarg);
  942.         }
  943.       else
  944.         lastarg=nil;
  945.     }
  946.       else
  947.     {
  948.       if (walker == nil)
  949.         {
  950.           CallError(stacktop,
  951.             "C function wants more args", op, NONCONTINUABLE);
  952.         }
  953.  
  954.       if (CDR(walker)!=nil)
  955.         CallError(stacktop,"Eval: Too many args to 'C-function",CDR(walker),
  956.               NONCONTINUABLE);
  957.       EUCALLSET_3(lastarg,module_eval,ARG_0(stackbase)/*mod*/,
  958.               ARG_1(stackbase)/*env*/,CAR(walker));
  959.     }
  960.       NARY_PUSH_ARG(lastarg);
  961.       op=ARG_3(stackbase);
  962.  
  963. #ifdef BCI
  964.       if (is_c_function(op)||is_c_macro(op))
  965.     return(NARY_EUCALL(op->C_FUNCTION.func));
  966.       else
  967.     {    /* B-function */
  968.       return(apply_nary_bytefunction(argbase,args,op));
  969.     }
  970. #else
  971.       return(NARY_EUCALL(op->C_FUNCTION.func));
  972. #endif
  973.       END_NARY_EUCALL();
  974.     }
  975.  
  976.   if (is_generic(op))
  977.     { 
  978.       RETURN_EUCALL(EUCALL_4(call_generic,mod,env,op,CDR(form)));
  979.     }
  980.  
  981.  
  982.   if (is_i_function(op)
  983.       || is_i_macro(op))
  984.     {
  985.       LispObject args, exps, callenv;
  986.       int extra;
  987.  
  988.       extra = ( op->I_FUNCTION.argtype < 0);
  989.       callenv = (LispObject) op->I_FUNCTION.env;
  990.       STACK_TMP(op);
  991.       if (op->I_FUNCTION.argtype == 0)
  992.     {
  993.       if (CDR(form)!=nil)
  994.         CallError(stackbase,"Too many args to I-function",op,NONCONTINUABLE);
  995.     }
  996.       else
  997.     {    
  998.       for ((args = op->I_FUNCTION.bvl,
  999.         exps = CDR(form));
  1000.            is_cons(args);
  1001.            (args = CDR(args),
  1002.         exps = CDR(exps)))
  1003.         {
  1004.           if (exps == nil)
  1005.         {
  1006.           CallError(stacktop,
  1007.                 "i function wants more args", op, NONCONTINUABLE);
  1008.         }
  1009.           else
  1010.         {
  1011.           LispObject nextarg;
  1012.  
  1013.           STACK_TMP(exps);
  1014.           STACK_TMP(args);
  1015.           STACK_TMP(callenv);
  1016.           EUCALLSET_3(nextarg,module_eval,
  1017.                   ARG_0(stackbase) /*mod*/,
  1018.                   ARG_1(stackbase) /*env*/,
  1019.                   CAR(exps));
  1020.           UNSTACK_TMP(callenv);
  1021.           UNSTACK_TMP(args);
  1022.           STACK_TMP(args);
  1023.           callenv = allocate_env(stacktop,CAR(args),
  1024.                      nextarg, callenv);
  1025.           UNSTACK_TMP(args);
  1026.           UNSTACK_TMP(exps);
  1027.  
  1028.         }
  1029.           /* end i-function-loop */
  1030.         }
  1031.                           
  1032.       /* last arg */
  1033.  
  1034.       if (extra)
  1035.         {
  1036.           LispObject lastarg=nil;
  1037.  
  1038.           STACK_TMP(callenv); /* need this */
  1039.           STACK_TMP(args);
  1040.  
  1041.           if (exps!=nil)
  1042.         {
  1043.           LispObject xx;
  1044.           LispObject ptr;
  1045.  
  1046.           STACK_TMP(CDR(exps));
  1047.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1048.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1049.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  1050.           UNSTACK_TMP(exps);
  1051.           STACK_TMP(lastarg);
  1052.           ptr = lastarg;
  1053.           while(exps!=nil)
  1054.             {    
  1055.               STACK_TMP(CDR(exps));
  1056.               STACK_TMP(ptr);
  1057.               EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1058.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1059.               xx = EUCALL_2(Fn_cons, xx, nil);
  1060.               UNSTACK_TMP(ptr);
  1061.               CDR(ptr)=xx;
  1062.               ptr = CDR(ptr);
  1063.               UNSTACK_TMP(exps);
  1064.             }
  1065.           UNSTACK_TMP(lastarg);
  1066.         }
  1067.           else
  1068.         lastarg=nil;
  1069.  
  1070.           UNSTACK_TMP(args);
  1071.           UNSTACK_TMP(callenv);
  1072.           callenv = allocate_env(stacktop,args,lastarg, callenv);
  1073.         }
  1074.       else if (exps!=nil)
  1075.         {    
  1076.           UNSTACK_TMP(op);
  1077.           CallError(stackbase,"Too many args to i-function",op,NONCONTINUABLE);
  1078.         }
  1079.     }
  1080.  
  1081.       UNSTACK_TMP(op);
  1082.       /* now we call it.., cunningly inlining the progn */
  1083.  
  1084.       { LispObject forms = op->I_FUNCTION.body;
  1085.     /* Throw it all away */
  1086.     stacktop=stackbase;
  1087.     SET_TRACE(stackbase-3,op,callenv);
  1088.  
  1089.     while (CDR(forms)!=nil)
  1090.       {
  1091.         STACK_TMP(CDR(forms));
  1092.         STACK_TMP(callenv);
  1093.         STACK_TMP(op);
  1094.         EUCALL_3(module_eval,
  1095.              op->I_FUNCTION.home,
  1096.              callenv,
  1097.              CAR(forms));
  1098.         UNSTACK_TMP(op);
  1099.         UNSTACK_TMP(callenv);
  1100.         UNSTACK_TMP(forms);
  1101.       }
  1102.  
  1103.     mod = ARG_0(stackbase) = op->I_FUNCTION.home;
  1104.     env = ARG_1(stackbase) = callenv;
  1105.     form = ARG_2(stackbase) = CAR(forms);
  1106.     goto toplabel;
  1107.       }
  1108.     }
  1109.   
  1110.   if (is_special(op))
  1111.     {
  1112.       if (op==special_progn)
  1113.     { LispObject forms = CDR(form);
  1114.     
  1115.       while (CDR(forms)!=nil)
  1116.         {
  1117.           STACK_TMP(CDR(forms));
  1118.           EUCALL_3(module_eval,
  1119.                ARG_0(stackbase)/*mod*/,
  1120.                ARG_1(stackbase)/*env*/,
  1121.                CAR(forms));
  1122.           UNSTACK_TMP(forms);
  1123.         }
  1124.  
  1125.       EUTAIL_3(ARG_0(stackbase)/*mod*/,
  1126.            ARG_1(stackbase)/*env*/,
  1127.            CAR(forms));
  1128.     }
  1129.       if (op == special_if)
  1130.     {    
  1131.       LispObject res,stmt=CDR(form);
  1132.       check_if(stmt);
  1133.       
  1134.       STACK_TMP(CDR(stmt));
  1135.       res = EUCALL_3(module_eval,mod,env,CAR(stmt));
  1136.       if ( res == nil)
  1137.         {
  1138.           UNSTACK_TMP(stmt);
  1139.           EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/
  1140.                ,CAR(CDR(stmt)));
  1141.         }
  1142.       UNSTACK_TMP(stmt);
  1143.       EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,CAR(stmt));
  1144.     }
  1145.  
  1146.       if (op->SPECIAL.env==NULL)
  1147.     RETURN_EUCALL(EUCALL_3(op->SPECIAL.func,mod,env,CDR(form)));
  1148.       else
  1149.     RETURN_EUCALL(EUCALL_2(op->SPECIAL.func,mod,CDR(form)));
  1150.     }
  1151.  
  1152.   if (is_continue(op))
  1153.     { LispObject res;
  1154.       
  1155.       res = EUCALL_3(module_eval,mod,env,CAR(CDR(form)));
  1156.       op=ARG_3(stackbase);
  1157.       call_continuation(stacktop,op,res);
  1158.       return nil; /* not really */
  1159.     }
  1160.  
  1161.  
  1162.  
  1163.   fprintf(stderr,"{?: 0x%x}",op);
  1164.   CallError(stacktop, "Unknown operator thing",op,NONCONTINUABLE);
  1165.   return nil; /* not ever */
  1166. }
  1167.  
  1168.  
  1169.  
  1170. /* The same, but different... we could be clever + do the tail call properly*/
  1171. EUFUN_4( call_generic, mod, env, gf, forms)
  1172. {
  1173.   LispObject lastarg;
  1174.   LispObject walker, extras = nil;
  1175.   int i, args, extra;
  1176.   BEGIN_NARY_EUCALL();
  1177.  
  1178.   walker = forms;
  1179.   args = intval(generic_argtype(gf));
  1180.   extra = (args < 0);
  1181.   args = extra ? -args : args;
  1182.  
  1183.   /* Too much cut and paste! */
  1184.   for (i=0; i < args-1 ; i++)
  1185.     {
  1186.       STACK_TMP(nil);        /* place where arg will go */
  1187.       STACK_TMP(CDR(walker));
  1188.       NARY_PUSH_ARG(EUCALL_3(module_eval,ARG_0(stackbase) /*mod*/,
  1189.                  ARG_1(stackbase) /* env */,CAR(walker)));
  1190.       UNSTACK_TMP(walker);
  1191.  
  1192.       if (walker == nil)
  1193.     {
  1194.       CallError(stacktop,
  1195.             "Generic function wants more args", gf, NONCONTINUABLE);
  1196.     }
  1197.     }
  1198.  
  1199.   if (extra)
  1200.     { 
  1201.       LispObject ptr;
  1202.  
  1203.       stacktop=argbase+argcount;
  1204.  
  1205.       if (walker!=nil)
  1206.     {
  1207.       STACK_TMP(CDR(walker));
  1208.       EUCALLSET_2(lastarg,Fn_cons,CAR(walker),nil);
  1209.       UNSTACK_TMP(walker);
  1210.       STACK_TMP(lastarg);
  1211.       ptr = lastarg;
  1212.       while(walker!=nil)
  1213.         {    
  1214.           LispObject xx;
  1215.           STACK_TMP(CDR(walker));
  1216.           STACK_TMP(ptr);
  1217.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase)/*mod*/, ARG_1(stackbase)/*env*/, CAR(walker));
  1218.           xx = EUCALL_2(Fn_cons, xx, nil);
  1219.           UNSTACK_TMP(ptr);
  1220.           CDR(ptr)=xx;
  1221.           ptr = CDR(ptr);
  1222.           UNSTACK_TMP(walker);
  1223.         }
  1224.       UNSTACK_TMP(lastarg);
  1225.     }
  1226.       else
  1227.     lastarg=nil;
  1228.     }
  1229.   else
  1230.     {     
  1231.       if (CDR(walker)!=nil)
  1232.     CallError(stacktop,"Eval: Too many args to Generic-function",CDR(walker),
  1233.           NONCONTINUABLE);
  1234.       EUCALLSET_3(lastarg,module_eval,ARG_0(stackbase) /*mod*/,ARG_1(stackbase)/*env*/,CAR(walker));
  1235.     }
  1236.   NARY_PUSH_ARG(lastarg);
  1237.   gf=ARG_2(stackbase);
  1238.   return(NARY_EUCALL_1(generic_apply,gf));
  1239.   END_NARY_EUCALL();
  1240. }
  1241. EUFUN_CLOSE
  1242.  
  1243. EUFUN_2(module_mv_apply_1,op, form)
  1244. {
  1245.   LispObject module_apply_args(LispObject *, int , LispObject );
  1246.   LispObject *walker=stackbase;
  1247.   int n=0;
  1248.  
  1249.   while (is_cons(form))
  1250.     {
  1251.       *walker=CAR(form);
  1252.       form=CDR(form);
  1253.       walker++;
  1254.       n++;
  1255.     }
  1256.  
  1257.   if (form!=nil)
  1258.     CallError(stackbase,"Improper list passed to mv_apply",nil,NONCONTINUABLE);
  1259.  
  1260.   return(module_apply_args(stackbase,n,op));
  1261.   
  1262. }
  1263. EUFUN_CLOSE
  1264.  
  1265. /* More restatement */
  1266. LispObject module_apply_args(LispObject *stackbase, int callargs, LispObject fn)
  1267. {
  1268.   void listify_args(LispObject *,int ,LispObject *);
  1269.   LispObject *stacktop=stackbase+callargs;
  1270.  
  1271.   if (is_i_function(fn) || is_i_macro(fn))
  1272.     {
  1273.       int nargs=fn->I_FUNCTION.argtype;
  1274.       LispObject env=fn->I_FUNCTION.env;
  1275.       LispObject args;
  1276.       LispObject *walker=stackbase;
  1277.       int extras;
  1278.       
  1279.       extras= (nargs<0);
  1280.       
  1281.       if (nargs==0 && callargs==0)
  1282.     RETURN_EUCALL(EUCALL_3(Sf_progn,
  1283.                    fn->I_FUNCTION.home,
  1284.                    env,
  1285.                    fn->I_FUNCTION.body));
  1286.  
  1287.       if ((callargs!=nargs && !extras) ||  (extras && callargs < -nargs-1))
  1288.     CallError(stackbase,"apply: i-function called with wrong number of args",fn,NONCONTINUABLE);
  1289.  
  1290.       STACK_TMP(fn);    /* we stack it twice on the off chance */
  1291.       STACK_TMP(fn);    /* it is an nary function called with n-1 args */
  1292.       for (args=fn->I_FUNCTION.bvl;
  1293.        is_cons(args);
  1294.        )
  1295.     {
  1296.       STACK_TMP(CDR(args));
  1297.       env=allocate_env(stacktop,CAR(args),*walker,env);
  1298.       walker++;
  1299.       UNSTACK_TMP(args);
  1300.     }
  1301.       if (extras)
  1302.     {
  1303.       STACK_TMP(env); STACK_TMP(args);
  1304.       listify_args(walker,callargs+nargs+1,stacktop);
  1305.       UNSTACK_TMP(args); UNSTACK_TMP(env);
  1306.       env=allocate_env(stacktop,args,*walker,env);
  1307.     }
  1308.       UNSTACK_TMP(fn);
  1309.       if (!is_i_function(fn) && !is_i_macro(fn))
  1310.     system_lisp_exit(0);
  1311.  
  1312.       RETURN_EUCALL(EUCALL_3(Sf_progn,
  1313.                  fn->I_FUNCTION.home,
  1314.                  env,
  1315.                  fn->I_FUNCTION.body));
  1316.       
  1317.     }    
  1318.   
  1319.   if (is_c_function(fn) || is_c_macro(fn) 
  1320. #ifdef BCI      
  1321.       || is_b_function(fn) || is_b_macro(fn)
  1322. #endif
  1323.       )
  1324.     {
  1325.       int nargs=
  1326.     ((is_c_function(fn)||is_c_macro(fn))
  1327.      ? fn->C_FUNCTION.argtype
  1328.      : intval(bytefunction_nargs(fn)));
  1329.       if (is_c_function(fn) && fn->C_FUNCTION.env!=NULL)
  1330.     {    /* Whups --- the env needs to be inserted */
  1331.       int i;
  1332.       
  1333.       for (i=callargs; i>=0; i--)
  1334.         stackbase[i+1]=stackbase[i];
  1335.  
  1336.       stackbase[0]=fn->C_FUNCTION.env;
  1337.     }
  1338.       if (callargs!=nargs)
  1339.     {
  1340.       if (nargs<0 && callargs>= -nargs-1)
  1341.         {    
  1342.           int act= -nargs-1;
  1343.           listify_args(stackbase+act,callargs-act,stacktop);
  1344.         }
  1345.       else
  1346.         CallError(stacktop,"C function called with wrong number of args",fn,NONCONTINUABLE);
  1347.     }
  1348. #ifdef BCI
  1349.       if (is_c_function(fn) || is_c_macro(fn))
  1350.     return((fn->C_FUNCTION.func)(stackbase));
  1351.       else
  1352.     return(apply_nary_bytefunction(stackbase,
  1353.                        nargs>0 ? nargs : -nargs,
  1354.                        fn));
  1355. #else
  1356.       return((fn->C_FUNCTION.func)(stackbase));
  1357. #endif      
  1358.     }            
  1359.  
  1360.   if (is_generic(fn))
  1361.     {    
  1362.       int nargs=intval(generic_argtype(fn));
  1363.       
  1364.       if (nargs!=callargs)
  1365.     CallError(stacktop,"Generic called with wrong number of args",fn,NONCONTINUABLE);
  1366.  
  1367.       return(generic_apply(stackbase,fn));
  1368.     }
  1369.  
  1370.   if (is_continue(fn))
  1371.     {
  1372.       if (callargs==0)
  1373.     {
  1374.       call_continuation(stackbase,fn,nil);
  1375.       return nil; 
  1376.     }
  1377.  
  1378.       if (callargs==1)
  1379.     {
  1380.       call_continuation(stackbase,fn,*stackbase);
  1381.     }
  1382.       CallError(stackbase,"apply: continuation: too many args",fn,NONCONTINUABLE);
  1383.       /* nope */
  1384.       return nil;
  1385.     }
  1386.  
  1387.   
  1388.   CallError(stacktop, "module multiple-apply: invalid op",fn,
  1389.         NONCONTINUABLE);
  1390.   return nil;
  1391. }
  1392.  
  1393. /* Should be a macro */
  1394. void listify_args(LispObject *start,int n,LispObject *stacktop)
  1395. {
  1396.   int i;
  1397.   LispObject lst;
  1398.  
  1399.   if (n==0)
  1400.     {
  1401.       *start=nil;
  1402.       return;
  1403.     }
  1404.   
  1405.   lst=allocate_n_conses(stacktop,n);
  1406.   CAR(lst)= *start;
  1407.   *start = lst;
  1408.  
  1409.   start++;
  1410.   lst=CDR(lst);
  1411.   for (i=1; i<n; i++)
  1412.     {
  1413.       CAR(lst) = *start;
  1414.       lst=CDR(lst);
  1415.       start++;
  1416.     }
  1417. }
  1418. #define SYM_REF_DBG(x) /* x;fflush(stderr); */
  1419.  
  1420. LispObject symbol_ref(LispObject *stacktop,
  1421.               LispObject mod,LispObject env,LispObject sym)
  1422. {
  1423.   Env walker;
  1424.   LispObject spec;
  1425.  
  1426. SYM_REF_DBG(fprintf(stderr,"symol_ref with sym '%s'\n",sym->symbol.pname));
  1427.  
  1428.   /* parameter environment */
  1429.  
  1430.   walker = &(env->ENV);
  1431.  
  1432. SYM_REF_DBG(fprintf(stderr,"symol_ref env search\n"));
  1433.  
  1434.   while (walker != NULL) {
  1435.     if (walker->variable == sym) 
  1436.       return(walker->value);
  1437.     else
  1438.       walker = walker->next;
  1439.   }
  1440.  
  1441.   /* self evaluating symbols */
  1442.  
  1443.   if (sym == sym_nil) return(nil);
  1444.   if (sym == lisptrue) return(lisptrue);
  1445.   
  1446.   /* Check caches */
  1447.   if (sym->SYMBOL.lmodule == mod) return(sym->SYMBOL.lvalue);
  1448.  
  1449.   /* language constructs and key words */
  1450.  
  1451.   spec=EUCALL_2(Fn_tref,special_table,sym);
  1452.  
  1453.   if (spec != nil) 
  1454.     {
  1455.       sym->SYMBOL.lmodule=mod;
  1456.       sym->SYMBOL.lvalue=spec;
  1457.       return spec;    
  1458.     }
  1459.   
  1460.   /* module reference */
  1461.  
  1462.   return(EUCALL_2(Fn_module_value,mod,sym));
  1463. }
  1464.  
  1465.  
  1466. LispObject module_set_new(LispObject *stacktop,LispObject mod,LispObject sym,LispObject val)
  1467. {
  1468.   return(EUCALL_4(module_set_new_aux,mod,sym,val,lisptrue));
  1469. }
  1470.  
  1471. LispObject module_set_new_constant(LispObject *stacktop,LispObject mod,
  1472.                    LispObject sym,LispObject val)
  1473. {
  1474.   return(EUCALL_4(module_set_new_aux,mod,sym,val,nil));
  1475. }
  1476.  
  1477.  
  1478. EUFUN_2(Fn_module_value, mod, sym)
  1479. {
  1480.   LispObject bind;
  1481.   
  1482.   bind=GET_BINDING(mod,sym);
  1483.  
  1484.   if (bind==nil)
  1485.     {
  1486.       LispObject xx;
  1487.       xx=EUCALL_2(Fn_cons,mod->MODULE.name,sym);
  1488.       CallError(stacktop,"module value: No such binding",xx,NONCONTINUABLE);
  1489.     }
  1490.   if (is_cons(bind))
  1491.     { /* Good value */
  1492.       LispObject val;
  1493.  
  1494.       if (is_i_module(BINDING_HOME(bind)))
  1495.     {
  1496.       val = BINDING_VALUE(bind);
  1497.       sym->SYMBOL.lmodule=mod;
  1498.       sym->SYMBOL.lvalue=val;
  1499.       return val;
  1500.     }
  1501.       if (is_c_module(BINDING_HOME(bind)))
  1502.     {
  1503.       val=(BINDING_HOME(bind)->C_MODULE.values)[intval(BINDING_VALUE(bind))];
  1504.       sym->SYMBOL.lmodule=mod;
  1505.       sym->SYMBOL.lvalue=val;
  1506.       return val;
  1507.     }
  1508.       else 
  1509.     CallError(stacktop,"Unexpected module type",bind,NONCONTINUABLE);    
  1510.     }
  1511.  
  1512.   CallError(stacktop,"Unexpected value of binding",bind,NONCONTINUABLE);
  1513.   return nil;
  1514. }
  1515. EUFUN_CLOSE
  1516.  
  1517. EUFUN_3(module_set,mod, sym, val)
  1518. {
  1519.   LispObject bind;
  1520.  
  1521.   
  1522.   if (is_c_module(mod))
  1523.     CallError(stacktop,"module set: can't set in compiled module",sym,NONCONTINUABLE);
  1524.  
  1525.   if(reserved_symbol_p(sym))
  1526.     CallError(stacktop,"module set: can't set reserved symbol",sym,NONCONTINUABLE);
  1527.  
  1528.   bind=GET_BINDING(mod,sym);
  1529.  
  1530.   if (bind==nil)
  1531.     {    /* Be kind and add it anyhow */
  1532.       sym->SYMBOL.lmodule=nil;
  1533.       sym->SYMBOL.lvalue=nil;
  1534.       ADD_BINDING(ARG_0(stackbase)/* mod*/, ARG_1(stackbase)/*sym*/,
  1535.           ARG_2(stackbase)/*val*/,lisptrue);
  1536.       return ARG_2(stackbase);
  1537.     }
  1538.   
  1539.   if (BINDING_HOME(bind)==mod)
  1540.     {
  1541.       if (BINDING_MUTABLE(bind)==lisptrue)
  1542.     {
  1543.       sym->SYMBOL.lmodule=nil;
  1544.       sym->SYMBOL.lvalue=nil;
  1545.       BINDING_VALUE(bind)=val;
  1546.       return val;
  1547.     }
  1548.       else
  1549.     {
  1550.       sym->SYMBOL.lmodule=nil;
  1551.       sym->SYMBOL.lvalue=nil;
  1552.  
  1553.       fprintf(StdErr->STREAM.handle,"*** Setting immutable binding\n");
  1554.       BINDING_VALUE(bind)=val;
  1555.       return val;
  1556.     }
  1557.     }
  1558.   
  1559.   CallError(stacktop,"module set: Tried to set over imported binding",sym,NONCONTINUABLE);
  1560.   return nil;
  1561. }
  1562. EUFUN_CLOSE
  1563.  
  1564. static EUFUN_4(module_set_new_aux,mod,sym,val,mutability)
  1565. {
  1566.   LispObject bind;
  1567.  
  1568.   if (!is_i_module(mod))
  1569.     CallError(stacktop,"Module set new: tried to set in compiled module",sym,NONCONTINUABLE);
  1570.  
  1571.   if(reserved_symbol_p(sym))
  1572.     CallError(stacktop,"module set: can't set reserved symbol",sym,NONCONTINUABLE);
  1573.  
  1574.   bind=GET_BINDING(mod,sym);
  1575.   
  1576.   if (bind==nil)
  1577.     { /* Its a newie */
  1578.       ADD_BINDING(ARG_0(stackbase),ARG_1(stackbase),ARG_2(stackbase),ARG_3(stackbase));
  1579.       sym->SYMBOL.lmodule=nil;
  1580.       sym->SYMBOL.lvalue=nil;
  1581.       return ARG_1(stackbase);
  1582.     }
  1583.   else
  1584.     {
  1585.       if (BINDING_HOME(bind)==mod)
  1586.     {
  1587.       sym->SYMBOL.lmodule=nil;
  1588.       sym->SYMBOL.lvalue=nil;
  1589.       BINDING_VALUE(bind)=val;
  1590.       BINDING_MUTABLE(bind)=mutability;
  1591.       return sym;
  1592.     }
  1593.       else
  1594.     CallError(stacktop,"Module set new: tried to set over imported binding",sym,NONCONTINUABLE);
  1595.     }
  1596.   /* NOT ever */
  1597.   return nil; 
  1598. }
  1599. EUFUN_CLOSE
  1600.  
  1601. EUFUN_4(register_module_import, mod, name, inmod, inname)
  1602. {
  1603.   LispObject bind, localbind;
  1604.   LispObject xx;
  1605.   if (is_c_module(mod))
  1606.     CallError(stacktop, "register import: can't import into compiled module",
  1607.           mod,NONCONTINUABLE);
  1608.  
  1609.   /* ok, but is it exported anyhow ? */
  1610.  
  1611.   EUCALLSET_2(xx, Fn_memq, inname, module_exports(inmod));
  1612.   if (xx == nil)
  1613.     CallError(stacktop, "register import: name not exported",inname,
  1614.           NONCONTINUABLE);
  1615.   
  1616.   /* Into canonical form */
  1617.  
  1618.   bind=GET_BINDING(inmod,inname);
  1619.   
  1620.   if (bind==nil)
  1621.     CallError(stacktop,"Tried to import non-existent binding", name,NONCONTINUABLE);
  1622.  
  1623.   /* See if we have something of the same name */
  1624.   localbind=GET_BINDING(mod,name);
  1625.  
  1626.   if (localbind==nil)
  1627.     { /* add it */
  1628.       IMPORT_BINDING(mod,name,bind);
  1629.       return nil;
  1630.     }
  1631.   else 
  1632.     {
  1633.       if (bind==localbind) /* done this before */
  1634.     return nil;
  1635.       else 
  1636.     CallError(stacktop,"register import: binding exists locally",nil,NONCONTINUABLE);
  1637.     }
  1638.  
  1639.   CallError(stacktop,"Register import: not here",nil,NONCONTINUABLE);
  1640.  
  1641.   return nil;
  1642. }
  1643. EUFUN_CLOSE
  1644.  
  1645. int module_binding_exists_p(LispObject *stacktop,LispObject mod,LispObject name)
  1646. {
  1647.   LispObject bind;
  1648.   
  1649.   bind=GET_BINDING(mod,name);
  1650.   
  1651.   return (bind!=nil);
  1652. }    
  1653.  
  1654.  
  1655. /* *************************************************************** */
  1656. /* Initialisation of this section                                  */
  1657. /* *************************************************************** */
  1658.  
  1659. void initialise_modules(LispObject *stacktop)
  1660. {
  1661.   extern LispObject current_open_module;
  1662.  
  1663.   sym_include_forms = get_symbol(stacktop,"include-forms");
  1664.   add_root(&sym_include_forms);
  1665.   SYSTEM_INITIALISE_GLOBAL(LispObject,current_interactive_module,NULL);
  1666.   ADD_SYSTEM_GLOBAL_ROOT(current_interactive_module);
  1667.   global_module_table = (LispObject) allocate_table(stacktop,Fn_eq);
  1668.   add_root(&global_module_table);
  1669.   add_root(¤t_open_module);
  1670.   backtrace_handle = get_symbol(stacktop,"****backtrace-handle****");
  1671.   add_root(&backtrace_handle);
  1672.   sym_only   = get_symbol(stacktop,"only");
  1673.   add_root(&sym_only);
  1674.   sym_except = get_symbol(stacktop,"except");
  1675.   add_root(&sym_except);
  1676. }
  1677.  
  1678.